home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / akcl / kcl.lha / cmpnew / cmptype.lsp < prev    next >
Lisp/Scheme  |  1987-06-03  |  7KB  |  182 lines
  1. ;;; CMPTYPE  Type information.
  2. ;;;
  3. ;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  4. ;; Copying of this file is authorized to users who have executed the true and
  5. ;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  6.  
  7. (in-package 'compiler)
  8.  
  9. ;;; CL-TYPE is any valid type specification of Common Lisp.
  10. ;;;
  11. ;;; TYPE is a representation type used by KCL.  TYPE is one of:
  12. ;;;
  13. ;;;                T(BOOLEAN)
  14. ;;;
  15. ;;;    FIXNUM  CHARACTER  SHORT-FLOAT  LONG-FLOAT
  16. ;;;    (VECTOR T)  STRING  BIT-VECTOR  (VECTOR FIXNUM)
  17. ;;;    (VECTOR SHORT-FLOAT)  (VECTOR LONG-FLOAT)
  18. ;;;    (ARRAY T)  (ARRAY STRING-CHAR)  (ARRAY BIT)
  19. ;;;    (ARRAY FIXNUM)
  20. ;;;    (ARRAY SHORT-FLOAT)  (ARRAY LONG-FLOAT)
  21. ;;;    UNKNOWN
  22. ;;;
  23. ;;;                NIL
  24. ;;;
  25. ;;;
  26. ;;; immediate-type:
  27. ;;;    FIXNUM        int
  28. ;;;    CHARACTER    char
  29. ;;;    SHORT-FLOAT    float
  30. ;;;    LONG-FLOAT    double
  31.  
  32.  
  33. ;;; Check if THING is an object of the type TYPE.
  34. ;;; Depends on the implementation of TYPE-OF.
  35. (defun object-type (thing)
  36.   (let ((type (type-of thing)))
  37.     (case type
  38.       ((fixnum short-float long-float) type)
  39.       ((string-char standard-char character) 'character)
  40.       ((string bit-vector) type)
  41.       (vector (list 'vector (array-element-type thing)))
  42.       (array (list 'array (array-element-type thing)))
  43.       (t 'unknown))))
  44.  
  45. (defun type-filter (type)
  46.   (case type
  47.         ((fixnum character short-float long-float) type)
  48.         (single-float 'long-float)
  49.         (double-float 'long-float)
  50.         ((simple-string string) 'string)
  51.         ((simple-bit-vector bit-vector) 'bit-vector)
  52.         (t (let ((type (si::normalize-type type)) element-type)
  53.              (case (car type)
  54.                ((simple-array array)
  55.                 (cond ((or (endp (cdr type))
  56.                            (not (setq element-type
  57.                                       (case (cadr type)
  58.                                         (* nil)
  59.                                         ((string-char standard-char character)
  60.                                          'string-char)
  61.                                         (bit 'bit)
  62.                                         (fixnum 'fixnum)
  63.                                         ((short-float)
  64.                                          'short-float)
  65.                                         ((long-float
  66.                                           double-float single-float)
  67.                                          'long-float)
  68.                                         (t t)))))
  69.                        t)    ; I don't know.
  70.                       ((and (not (endp (cddr type)))
  71.                             (not (eq (caddr type) '*))
  72.                             (= (length (caddr type)) 1))
  73.                        (case element-type
  74.                          (string-char 'string)
  75.                          (bit 'bit-vector)
  76.                          (t (list 'vector element-type))))
  77.                       (t (list 'array element-type))))
  78.                (integer
  79.                 (if (si::sub-interval-p (cdr type)
  80.                                         (list most-negative-fixnum
  81.                                               most-positive-fixnum))
  82.                     'fixnum
  83.                     t))
  84.                ((short-float) 'short-float)
  85.                ((long-float double-float single-float) 'long-float)
  86.                (t (cond ((subtypep type 'fixnum) 'fixnum)
  87.                         ((subtypep type 'character) 'character)
  88.                         ((subtypep type 'short-float) 'short-float)
  89.                         ((subtypep type 'long-float) 'long-float)
  90.                         ((subtypep type '(vector t)) '(vector t))
  91.                         ((subtypep type 'string) 'string)
  92.                         ((subtypep type 'bit-vector) 'bit-vector)
  93.                         ((subtypep type '(vector fixnum)) '(vector fixnum))
  94.                         ((subtypep type '(vector short-float))
  95.                          '(vector short-float))
  96.                         ((subtypep type '(vector long-float))
  97.                          '(vector long-float))
  98.                         ((subtypep type '(array t)) '(array t))
  99.                         ((subtypep type '(array string-char))
  100.                          '(array string-char))
  101.                         ((subtypep type '(array bit)) '(array bit))
  102.                         ((subtypep type '(array fixnum)) '(array fixnum))
  103.                         ((subtypep type '(array short-float))
  104.                          '(array short-float))
  105.                         ((subtypep type '(array long-float))
  106.                          '(array long-float))
  107.                         (t t)))
  108.                )))))
  109.  
  110. (defun type-and (type1 type2)
  111.   (cond ((equal type1 type2) type1)
  112.         ((eq type1 t) type2)
  113.         ((eq type2 t) type1)
  114.         ((consp type1)
  115.          (case (car type1)
  116.                (array
  117.                 (case (cadr type1)
  118.                       (string-char (if (eq type2 'string) type2 nil))
  119.                       (bit (if (eq type2 'bit-vector) type2 nil))
  120.                       (t (if (and (consp type2)
  121.                                   (eq (car type2) 'vector)
  122.                                   (eq (cadr type1) (cadr type2)))
  123.                              type2 nil))))
  124.                (vector
  125.                 (if (and (consp type2) (eq (car type2) 'array)
  126.                          (eq (cadr type1) (cadr type2)))
  127.                     type1 nil))
  128.                (t nil)))
  129.         (t (case type1
  130.                  (string
  131.                   (if (and (consp type2) (eq (car type2) 'array)
  132.                            (eq (cadr type2) 'string-char))
  133.                       type1 nil))
  134.                  (bit-vector
  135.                   (if (and (consp type2) (eq (car type2) 'array)
  136.                            (eq (cadr type2) 'bit))
  137.                       type1 nil))
  138.                  (fixnum-float
  139.                   (if (member type2 '(fixnum float short-float long-float))
  140.                       type2 nil))
  141.                  (float
  142.                   (if (member type2 '(short-float long-float))
  143.                       type2 nil))
  144.                  ((long-float short-float)
  145.                   (if (member type2 '(fixnum-float float))
  146.                       type1 nil))
  147.                  (fixnum
  148.                   (if (eq type2 'fixnum-float) 'fixnum nil))))))
  149.  
  150. (defun type>= (type1 type2)
  151.   (equal (type-and type1 type2) type2))
  152.  
  153. (defun reset-info-type (info)
  154.   (if (info-type info)
  155.       (let ((info1 (copy-info info)))
  156.            (setf (info-type info1) t)
  157.            info1)
  158.       info))
  159.  
  160. (defun and-form-type (type form original-form &aux type1)
  161.   (setq type1 (type-and type (info-type (cadr form))))
  162.   (when (null type1)
  163.         (cmpwarn "The type of the form ~s is not ~s." original-form type))
  164.   (if (eq type1 (info-type (cadr form)))
  165.       form
  166.       (let ((info (copy-info (cadr form))))
  167.            (setf (info-type info) type1)
  168.            (list* (car form) info (cddr form)))))
  169.  
  170. (defun check-form-type (type form original-form)
  171.   (when (null (type-and type (info-type (cadr form))))
  172.         (cmpwarn "The type of the form ~s is not ~s." original-form type)))
  173.  
  174. (defun default-init (type)
  175.   (case type
  176.         (fixnum (cmpwarn "The default value of NIL is not FIXNUM."))
  177.         (character (cmpwarn "The default value of NIL is not CHARACTER."))
  178.         (long-float (cmpwarn "The default value of NIL is not LONG-FLOAT."))
  179.         (short-float (cmpwarn "The default value of NIL is not SHORT-FLOAT."))
  180.         )
  181.   (c1nil))
  182.